home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue45 / Clinic / DBHntGrd.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-11-02  |  6.9 KB  |  256 lines
  1. unit DBHntGrd;
  2. {$ifdef Ver80} { Delphi 1.0x }
  3.   {$define DelphiLessThan3}
  4. {$endif}
  5. {$ifdef Ver90} { Delphi 2.0x }
  6.   {$define DelphiLessThan3}
  7. {$endif}
  8. {$ifdef Ver93} { C++ Builder 1.0x }
  9.   {$define DelphiLessThan3}
  10. {$endif}
  11.  
  12. interface
  13.  
  14. uses
  15.   WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  16.   Dialogs, Grids, DBGrids;
  17.  
  18. type
  19.   THintDBGrid = class(TDBGrid)
  20.   private
  21.     FHintWnd: THintWindow;
  22.   protected
  23.     function CalcHintRect(MaxWidth: Integer;
  24.       const AHint: string; HintWnd: THintWindow): TRect;
  25.     procedure DoHint(X, Y: Integer);
  26.   public
  27.     procedure CMMouseEnter(var Msg: TMessage); message cm_MouseEnter;
  28.     procedure CMMouseLeave(var Msg: TMessage); message cm_MouseLeave;
  29.     procedure WMMouseMove(var Msg: TWMMouseMove); message wm_MouseMove;
  30.   end;
  31.  
  32. {$ifdef DelphiLessThan3}
  33.   { The hint window in Delphi 1 and 2 would beep if you clicked it }
  34.   { These modifications fix that }
  35.   TCustomHint = class(THintWindow)
  36.   private
  37.     procedure WMNCHitTest(var Msg: TWMNCHitTest);
  38.       message wm_NCHitTest;
  39.   protected
  40.     procedure CreateParams(var Params: TCreateParams); override;
  41.   end;
  42.  
  43. { The private routine Forms.ForegroundTask was only made }
  44. { available in Delphi 3. This is a cheap'n'nasty version of it }
  45. function ForegroundTask: Boolean;
  46. {$endif}
  47.  
  48. procedure Register;
  49.  
  50. implementation
  51.  
  52. uses
  53.   DB, DBTables;
  54.  
  55. procedure Register;
  56. begin
  57.   RegisterComponents('Clinic', [THintDBGrid]);
  58. end;
  59.  
  60. {$ifdef DelphiLessThan3}
  61. { The private routine Forms.ForegroundTask was only made }
  62. { available in Delphi 3. This is a cheap'n'nasty version of it }
  63. function ForegroundTask: Boolean;
  64. begin
  65.   Result := FindControl(GetActiveWindow) <> nil
  66. end;
  67. {$endif}
  68.  
  69. { THintStringGrid }
  70.  
  71. function THintDBGrid.CalcHintRect(MaxWidth: Integer;
  72.   const AHint: string; HintWnd: THintWindow): TRect;
  73. {$ifdef DelphiLessThan3}
  74. var
  75.   Buf: PChar;
  76. begin
  77.   Result := Rect(0, 0, MaxWidth, 0);
  78.   { Translate Pascal string to C, but take care of possible problematic }
  79.   { values. Delphi 2 sometimes copies less than the full memo with StrPCopy }
  80.   Buf := StrAlloc(Length(AHint) + 1);
  81.   try
  82.   {$ifdef Win32}
  83.     Move(AHint[1], Buf^, Length(AHint));
  84.   {$else}
  85.     StrPCopy(Buf, AHint);
  86.   {$endif}
  87.     { Ask Windows to do the hard calculation work }
  88.     DrawText(HintWnd.Canvas.Handle, Buf, -1, Result,
  89.       DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
  90.   finally
  91.     StrDispose(Buf);
  92.   end;
  93.   { Add some breathing room }
  94.   Inc(Result.Right, 6);
  95.   Inc(Result.Bottom, 2);
  96. {$else}
  97. begin
  98.   { Delphi 3+ makes this method available }
  99.   Result := HintWnd.CalcHintRect(Screen.Width, AHint, nil)
  100. {$endif}
  101. end;
  102.  
  103. procedure THintDBGrid.CMMouseEnter(var Msg: TMessage);
  104. var
  105.   Pt: TPoint;
  106. begin
  107.   GetCursorPos(Pt);
  108.   Pt := ScreenToClient(Pt);
  109.   DoHint(Pt.X, Pt.Y)
  110. end;
  111.  
  112. procedure THintDBGrid.CMMouseLeave(var Msg: TMessage);
  113. begin
  114.   inherited;
  115.   { Could destroy it, but this takes less time }
  116.   if Assigned(FHintWnd) then
  117.     FHintWnd.ReleaseHandle;
  118. end;
  119.  
  120. procedure THintDBGrid.DoHint(X, Y: Integer);
  121. const
  122.   TextOffset = 2;
  123. var
  124.   Col, Row, LogCol, LogRow: Longint;
  125.   R, OldR: TRect;
  126.   Pt: TPoint;
  127.   GPt: TGridCoord;
  128.   OldActive: Integer;
  129.   Text: String;
  130. {$ifndef Win32}
  131.   CText: PChar;
  132. {$endif}
  133. begin
  134.   { Check cell under mouse }
  135.   GPt := MouseCoord(X, Y);
  136.   Col := GPt.X;
  137.   Row := GPt.Y;
  138.   LogCol := Col;
  139.   LogRow := Row;
  140.   { Title row needs to be taken account of }
  141.   if dgTitles in Options then Dec(LogRow);
  142.   { Indicator column needs to be taken account of }
  143.   if dgIndicator in Options then Dec(LogCol);
  144.   Text := '';
  145.   if (LogCol >= 0) and (LogRow >= 0) then
  146.   begin
  147.     { Get field text, taking memo fields into account }
  148.     OldActive := DataLink.ActiveRecord;
  149.     try
  150.       Datalink.ActiveRecord := LogRow;
  151.     {$ifdef Win32}
  152.       { Delphi 2+ is easy for memos }
  153.       if not (Columns[LogCol].Field is TMemoField) then
  154.         Text := Columns[LogCol].Field.DisplayText
  155.       else
  156.       begin
  157.         Text := Columns[LogCol].Field.AsString;
  158.       end
  159.     {$else}
  160.       { Delphi 1 is more tricky for memos - best I can manage }
  161.       { is to copy contents to a string list and work from that }
  162.       if not (Fields[LogCol] is TMemoField) then
  163.         Text := Fields[LogCol].DisplayText
  164.       else
  165.         with TStringList.Create do
  166.           try
  167.             Assign(Fields[LogCol]);
  168.             CText := GetText;
  169.             try
  170.               { Delphi 1 strings are at most 255 characters }
  171.               if StrLen(CText) > 255 then
  172.                 Text := Copy(StrPas(CText), 1, 252) + '...'
  173.               else
  174.                 Text := StrPas(CText)
  175.             finally
  176.               StrDispose(CText)
  177.             end
  178.           finally
  179.             Free
  180.           end;
  181.     {$endif}
  182.     finally
  183.       Datalink.ActiveRecord := OldActive
  184.     end
  185.   end;
  186.   { If it is a cell, and in-place editor not present, }
  187.   { and text is bigger than screen space, and not at design-time }
  188.   Canvas.Font := Font;
  189.   if (Text <> '') and not EditorMode and ForegroundTask and
  190.      (Canvas.TextWidth(Text) + TextOffset > ColWidths[Col]) and
  191.      not (csDesigning in ComponentState) then
  192.   begin
  193.     { Make sure hint window exists }
  194.     if not Assigned(FHintWnd) then
  195.     begin
  196.       FHintWnd := HintWindowClass.Create(Self);
  197.       FHintWnd.Color := Application.HintColor;
  198.     end;
  199.     { Set hint text }
  200.     Hint := Text;
  201.     { Calculate rect size }
  202.     R := CalcHintRect(Screen.Width, Hint, FHintWnd);
  203.  
  204.     { Find target location }
  205.     Pt := ClientToScreen(CellRect(Col, Row).TopLeft);
  206.     { Tweak position so it is the same as the grid cell (hopefully) }
  207.   {$ifdef DelphiLessThan3}
  208.     Inc(Pt.Y);
  209.   {$else}
  210.     Dec(Pt.X);
  211.     Dec(Pt.Y);
  212.   {$endif}
  213.     OffsetRect(R, Pt.X, Pt.Y);
  214.     if R.Right > Screen.Width then
  215.       OffsetRect(R, Screen.Width - R.Right, 0);
  216.     if R.Bottom > Screen.Height then
  217.       OffsetRect(R, Screen.Height - R.Bottom, 0);
  218.     { Only draw it if it has moved - compare top-left }
  219.     { (could compare whole rect but the hint sometimes grows itself) }
  220.     GetWindowRect(FHintWnd.Handle, OldR);
  221.     if not IsWindowVisible(FHintWnd.Handle) or
  222.        not ((R.Left = OldR.Left) and (R.Top = OldR.Top)) then
  223.       FHintWnd.ActivateHint(R, Hint)
  224.   end
  225.   else
  226.     if Assigned(FHintWnd) then
  227.       FHintWnd.ReleaseHandle
  228. end;
  229.  
  230. procedure THintDBGrid.WMMouseMove(var Msg: TWMMouseMove);
  231. begin
  232.   inherited;
  233.   DoHint(Msg.XPos, Msg.YPos)
  234. end;
  235.  
  236. {$ifdef DelphiLessThan3}
  237. { TCustomHint }
  238.  
  239. procedure TCustomHint.CreateParams(var Params: TCreateParams);
  240. begin
  241.   inherited CreateParams(Params);
  242.   Params.Style := Params.Style and not ws_Disabled;
  243. end;
  244.  
  245. procedure TCustomHint.WMNCHitTest(var Msg: TWMNCHitTest);
  246. begin
  247.   Msg.Result := HTTRANSPARENT;
  248. end;
  249.  
  250. initialization
  251.   Application.ShowHint := not Application.ShowHint;
  252.   HintWindowClass := TCustomHint;
  253.   Application.ShowHint := not Application.ShowHint;
  254. {$endif}
  255. end.
  256.